home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclIOCmd.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  44.2 KB  |  1,556 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclIOCmd.c --
  3.  *
  4.  *    Contains the definitions of most of the Tcl commands relating to IO.
  5.  *
  6.  * Copyright (c) 1995-1996 Sun Microsystems, Inc.
  7.  *
  8.  * See the file "license.terms" for information on usage and redistribution
  9.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10.  *
  11.  * SCCS: @(#) tclIOCmd.c 1.119 97/07/25 20:49:23
  12.  */
  13.  
  14. #include    "tclInt.h"
  15. #include    "tclPort.h"
  16.  
  17. /*
  18.  * Return at most this number of bytes in one call to Tcl_Read:
  19.  */
  20.  
  21. #define    TCL_READ_CHUNK_SIZE    4096
  22.  
  23. /*
  24.  * Callback structure for accept callback in a TCP server.
  25.  */
  26.  
  27. typedef struct AcceptCallback {
  28.     char *script;            /* Script to invoke. */
  29.     Tcl_Interp *interp;            /* Interpreter in which to run it. */
  30. } AcceptCallback;
  31.  
  32. /*
  33.  * Static functions for this file:
  34.  */
  35.  
  36. static void    AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData,
  37.                 Tcl_Channel chan, char *address, int port));
  38. static void    RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp,
  39.                 AcceptCallback *acceptCallbackPtr));
  40. static void    TcpAcceptCallbacksDeleteProc _ANSI_ARGS_((
  41.             ClientData clientData, Tcl_Interp *interp));
  42. static void    TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData));
  43. static void    UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_((
  44.             Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr));
  45.  
  46. /*
  47.  *----------------------------------------------------------------------
  48.  *
  49.  * Tcl_PutsObjCmd --
  50.  *
  51.  *    This procedure is invoked to process the "puts" Tcl command.
  52.  *    See the user documentation for details on what it does.
  53.  *
  54.  * Results:
  55.  *    A standard Tcl result.
  56.  *
  57.  * Side effects:
  58.  *    Produces output on a channel.
  59.  *
  60.  *----------------------------------------------------------------------
  61.  */
  62.  
  63.     /* ARGSUSED */
  64. int
  65. Tcl_PutsObjCmd(dummy, interp, objc, objv)
  66.     ClientData dummy;        /* Not used. */
  67.     Tcl_Interp *interp;        /* Current interpreter. */
  68.     int objc;            /* Number of arguments. */
  69.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  70. {
  71.     Tcl_Channel chan;            /* The channel to puts on. */
  72.     int i;                /* Counter. */
  73.     int newline;            /* Add a newline at end? */
  74.     char *channelId;            /* Name of channel for puts. */
  75.     int result;                /* Result of puts operation. */
  76.     int mode;                /* Mode in which channel is opened. */
  77.     char *arg;
  78.     int length;
  79.     Tcl_Obj *resultPtr;
  80.  
  81.     i = 1;
  82.     newline = 1;
  83.     if ((objc >= 2) && (strcmp(Tcl_GetStringFromObj(objv[1], NULL),
  84.         "-nonewline") == 0)) {
  85.     newline = 0;
  86.     i++;
  87.     }
  88.     if ((i < (objc-3)) || (i >= objc)) {
  89.     Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
  90.     return TCL_ERROR;
  91.     }
  92.  
  93.     /*
  94.      * The code below provides backwards compatibility with an old
  95.      * form of the command that is no longer recommended or documented.
  96.      */
  97.  
  98.     resultPtr = Tcl_NewObj();
  99.     if (i == (objc-3)) {
  100.     arg = Tcl_GetStringFromObj(objv[i+2], &length);
  101.     if (strncmp(arg, "nonewline", (size_t) length) != 0) {
  102.         Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg,
  103.             "\": should be \"nonewline\"", (char *) NULL);
  104.             Tcl_SetObjResult(interp, resultPtr);
  105.         return TCL_ERROR;
  106.     }
  107.     newline = 0;
  108.     }
  109.     if (i == (objc-1)) {
  110.     channelId = "stdout";
  111.     } else {
  112.     channelId = Tcl_GetStringFromObj(objv[i], NULL);
  113.     i++;
  114.     }
  115.     chan = Tcl_GetChannel(interp, channelId, &mode);
  116.     if (chan == (Tcl_Channel) NULL) {
  117.         Tcl_DecrRefCount(resultPtr);
  118.         return TCL_ERROR;
  119.     }
  120.     if ((mode & TCL_WRITABLE) == 0) {
  121.     Tcl_AppendStringsToObj(resultPtr, "channel \"", channelId,
  122.                 "\" wasn't opened for writing", (char *) NULL);
  123.         Tcl_SetObjResult(interp, resultPtr);
  124.         return TCL_ERROR;
  125.     }
  126.  
  127.     arg = Tcl_GetStringFromObj(objv[i], &length);
  128.     result = Tcl_Write(chan, arg, length);
  129.     if (result < 0) {
  130.         goto error;
  131.     }
  132.     if (newline != 0) {
  133.         result = Tcl_Write(chan, "\n", 1);
  134.         if (result < 0) {
  135.             goto error;
  136.         }
  137.     }
  138.     Tcl_SetObjResult(interp, resultPtr);
  139.     return TCL_OK;
  140. error:
  141.     Tcl_AppendStringsToObj(resultPtr, "error writing \"",
  142.         Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
  143.         (char *) NULL);
  144.     Tcl_SetObjResult(interp, resultPtr);
  145.     return TCL_ERROR;
  146. }
  147.  
  148. /*
  149.  *----------------------------------------------------------------------
  150.  *
  151.  * Tcl_FlushObjCmd --
  152.  *
  153.  *    This procedure is called to process the Tcl "flush" command.
  154.  *    See the user documentation for details on what it does.
  155.  *
  156.  * Results:
  157.  *    A standard Tcl result.
  158.  *
  159.  * Side effects:
  160.  *    May cause output to appear on the specified channel.
  161.  *
  162.  *----------------------------------------------------------------------
  163.  */
  164.  
  165.     /* ARGSUSED */
  166. int
  167. Tcl_FlushObjCmd(dummy, interp, objc, objv)
  168.     ClientData dummy;        /* Not used. */
  169.     Tcl_Interp *interp;        /* Current interpreter. */
  170.     int objc;            /* Number of arguments. */
  171.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  172. {
  173.     Tcl_Channel chan;            /* The channel to flush on. */
  174.     char *arg;
  175.     Tcl_Obj *resultPtr;
  176.     int mode;
  177.  
  178.     if (objc != 2) {
  179.     Tcl_WrongNumArgs(interp, 1, objv, "channelId");
  180.     return TCL_ERROR;
  181.     }
  182.     arg = Tcl_GetStringFromObj(objv[1], NULL);
  183.     chan = Tcl_GetChannel(interp, arg, &mode);
  184.     if (chan == (Tcl_Channel) NULL) {
  185.     return TCL_ERROR;
  186.     }
  187.     resultPtr = Tcl_GetObjResult(interp);
  188.     if ((mode & TCL_WRITABLE) == 0) {
  189.     Tcl_AppendStringsToObj(resultPtr, "channel \"",
  190.         Tcl_GetStringFromObj(objv[1], NULL), 
  191.                 "\" wasn't opened for writing", (char *) NULL);
  192.         return TCL_ERROR;
  193.     }
  194.     
  195.     if (Tcl_Flush(chan) != TCL_OK) {
  196.     Tcl_AppendStringsToObj(resultPtr, "error flushing \"",
  197.         Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
  198.         (char *) NULL);
  199.     return TCL_ERROR;
  200.     }
  201.     return TCL_OK;
  202. }
  203.  
  204. /*
  205.  *----------------------------------------------------------------------
  206.  *
  207.  * Tcl_GetsObjCmd --
  208.  *
  209.  *    This procedure is called to process the Tcl "gets" command.
  210.  *    See the user documentation for details on what it does.
  211.  *
  212.  * Results:
  213.  *    A standard Tcl result.
  214.  *
  215.  * Side effects:
  216.  *    May consume input from channel.
  217.  *
  218.  *----------------------------------------------------------------------
  219.  */
  220.  
  221.     /* ARGSUSED */
  222. int
  223. Tcl_GetsObjCmd(dummy, interp, objc, objv)
  224.     ClientData dummy;        /* Not used. */
  225.     Tcl_Interp *interp;        /* Current interpreter. */
  226.     int objc;            /* Number of arguments. */
  227.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  228. {
  229.     Tcl_Channel chan;            /* The channel to read from. */
  230.     int lineLen;            /* Length of line just read. */
  231.     int mode;                /* Mode in which channel is opened. */
  232.     char *arg;
  233.     Tcl_Obj *resultPtr, *objPtr;
  234.  
  235.     if ((objc != 2) && (objc != 3)) {
  236.     Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
  237.     return TCL_ERROR;
  238.     }
  239.     arg = Tcl_GetStringFromObj(objv[1], NULL);
  240.     chan = Tcl_GetChannel(interp, arg, &mode);
  241.     if (chan == (Tcl_Channel) NULL) {
  242.     return TCL_ERROR;
  243.     }
  244.     resultPtr = Tcl_NewObj();
  245.     if ((mode & TCL_READABLE) == 0) {
  246.     Tcl_AppendStringsToObj(resultPtr, "channel \"", arg,
  247.                 "\" wasn't opened for reading", (char *) NULL);
  248.         Tcl_SetObjResult(interp, resultPtr);
  249.         return TCL_ERROR;
  250.     }
  251.  
  252.     lineLen = Tcl_GetsObj(chan, resultPtr);
  253.     if (lineLen < 0) {
  254.         if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
  255.         Tcl_SetObjLength(resultPtr, 0);
  256.         Tcl_AppendStringsToObj(resultPtr, "error reading \"",
  257.             Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
  258.             (char *) NULL);
  259.             Tcl_SetObjResult(interp, resultPtr);
  260.             return TCL_ERROR;
  261.         }
  262.         lineLen = -1;
  263.     }
  264.     if (objc == 3) {
  265.     Tcl_ResetResult(interp);
  266.     objPtr = Tcl_ObjSetVar2(interp, objv[2], NULL,
  267.         resultPtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
  268.     if (objPtr == NULL) {
  269.             Tcl_DecrRefCount(resultPtr);
  270.             return TCL_ERROR;
  271.         }
  272.         Tcl_ResetResult(interp);
  273.     Tcl_SetIntObj(Tcl_GetObjResult(interp), lineLen);
  274.         return TCL_OK;
  275.     }
  276.     Tcl_SetObjResult(interp, resultPtr);
  277.     return TCL_OK;
  278. }
  279.  
  280. /*
  281.  *----------------------------------------------------------------------
  282.  *
  283.  * Tcl_ReadObjCmd --
  284.  *
  285.  *    This procedure is invoked to process the Tcl "read" command.
  286.  *    See the user documentation for details on what it does.
  287.  *
  288.  * Results:
  289.  *    A standard Tcl result.
  290.  *
  291.  * Side effects:
  292.  *    May consume input from channel.
  293.  *
  294.  *----------------------------------------------------------------------
  295.  */
  296.  
  297.     /* ARGSUSED */
  298. int
  299. Tcl_ReadObjCmd(dummy, interp, objc, objv)
  300.     ClientData dummy;        /* Not used. */
  301.     Tcl_Interp *interp;        /* Current interpreter. */
  302.     int objc;            /* Number of arguments. */
  303.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  304. {
  305.     Tcl_Channel chan;            /* The channel to read from. */
  306.     int newline, i;            /* Discard newline at end? */
  307.     int toRead;                /* How many bytes to read? */
  308.     int toReadNow;            /* How many bytes to attempt to
  309.                                          * read in the current iteration? */
  310.     int charactersRead;            /* How many characters were read? */
  311.     int charactersReadNow;        /* How many characters were read
  312.                                          * in this iteration? */
  313.     int mode;                /* Mode in which channel is opened. */
  314.     int bufSize;            /* Channel buffer size; used to decide
  315.                                          * in what chunk sizes to read from
  316.                                          * the channel. */
  317.     char *arg;
  318.     Tcl_Obj *resultPtr;
  319.  
  320.     if ((objc != 2) && (objc != 3)) {
  321. argerror:
  322.     Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numBytes?");
  323.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " or \"",
  324.         Tcl_GetStringFromObj(objv[0], NULL),
  325.         " ?-nonewline? channelId\"", (char *) NULL);
  326.     return TCL_ERROR;
  327.     }
  328.     i = 1;
  329.     newline = 0;
  330.     if (strcmp(Tcl_GetStringFromObj(objv[1], NULL), "-nonewline") == 0) {
  331.     newline = 1;
  332.     i++;
  333.     }
  334.  
  335.     if (i == objc) {
  336.         goto argerror;
  337.     }
  338.  
  339.     arg =  Tcl_GetStringFromObj(objv[i], NULL);
  340.     chan = Tcl_GetChannel(interp, arg, &mode);
  341.     if (chan == (Tcl_Channel) NULL) {
  342.     return TCL_ERROR;
  343.     }
  344.     if ((mode & TCL_READABLE) == 0) {
  345.     resultPtr = Tcl_GetObjResult(interp);
  346.     Tcl_AppendStringsToObj(resultPtr, "channel \"", arg,
  347.                 "\" wasn't opened for reading", (char *) NULL);
  348.         return TCL_ERROR;
  349.     }
  350.     
  351.     i++;    /* Consumed channel name. */
  352.  
  353.     /*
  354.      * Compute how many bytes to read, and see whether the final
  355.      * newline should be dropped.
  356.      */
  357.  
  358.     toRead = INT_MAX;
  359.     if (i < objc) {
  360.     arg = Tcl_GetStringFromObj(objv[i], NULL);
  361.     if (isdigit((unsigned char) (arg[0]))) {
  362.         if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
  363.                 return TCL_ERROR;
  364.         }
  365.         Tcl_ResetResult(interp);
  366.     } else if (strcmp(arg, "nonewline") == 0) {
  367.         newline = 1;
  368.     } else {
  369.         resultPtr = Tcl_GetObjResult(interp);
  370.         Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg,
  371.             "\": should be \"nonewline\"", (char *) NULL);
  372.         return TCL_ERROR;
  373.         }
  374.     }
  375.  
  376.     /*
  377.      * Create a new object and use that instead of the interpreter
  378.      * result. We cannot use the interpreter's result object because
  379.      * it may get smashed at any time by recursive calls.
  380.      */
  381.     
  382.     resultPtr = Tcl_NewObj();
  383.     
  384.     bufSize = Tcl_GetChannelBufferSize(chan);
  385.  
  386.     /*
  387.      * If the caller specified a maximum length to read, then that is
  388.      * a good size to preallocate.
  389.      */
  390.     
  391.     if ((toRead != INT_MAX) && (toRead > bufSize)) {
  392.         Tcl_SetObjLength(resultPtr, toRead);
  393.     }
  394.     
  395.     for (charactersRead = 0; charactersRead < toRead; ) {
  396.         toReadNow = toRead - charactersRead;
  397.         if (toReadNow > bufSize) {
  398.             toReadNow = bufSize;
  399.         }
  400.  
  401.         /*
  402.          * NOTE: This is a NOOP if we set the size (above) to the
  403.          * number of bytes we expect to read. In the degenerate
  404.          * case, however, it will grow the buffer by the channel
  405.          * buffersize, which is 4K in most cases. This will result
  406.          * in inefficient copying for large files. This will be
  407.          * fixed in a future release.
  408.          */
  409.         
  410.     Tcl_SetObjLength(resultPtr, charactersRead + toReadNow);
  411.         charactersReadNow =
  412.             Tcl_Read(chan, Tcl_GetStringFromObj(resultPtr, NULL)
  413.             + charactersRead, toReadNow);
  414.         if (charactersReadNow < 0) {
  415.         Tcl_SetObjLength(resultPtr, 0);
  416.             Tcl_AppendStringsToObj(resultPtr, "error reading \"",
  417.             Tcl_GetChannelName(chan), "\": ",
  418.             Tcl_PosixError(interp), (char *) NULL);
  419.             Tcl_SetObjResult(interp, resultPtr);
  420.  
  421.             return TCL_ERROR;
  422.         }
  423.  
  424.         /*
  425.          * If we had a short read it means that we have either EOF
  426.          * or BLOCKED on the channel, so break out.
  427.          */
  428.         
  429.         charactersRead += charactersReadNow;
  430.  
  431.         /*
  432.          * Do not call the driver again if we got a short read
  433.          */
  434.         
  435.         if (charactersReadNow < toReadNow) {
  436.             break;    /* Out of "for" loop. */
  437.         }
  438.     }
  439.     
  440.     /*
  441.      * If requested, remove the last newline in the channel if at EOF.
  442.      */
  443.     
  444.     if ((charactersRead > 0) && (newline) &&
  445.           (Tcl_GetStringFromObj(resultPtr, NULL)[charactersRead-1] == '\n')) {
  446.     charactersRead--;
  447.     }
  448.     Tcl_SetObjLength(resultPtr, charactersRead);
  449.  
  450.     /*
  451.      * Now set the object into the interpreter result and release our
  452.      * hold on it by decrrefing it.
  453.      */
  454.  
  455.     Tcl_SetObjResult(interp, resultPtr);
  456.     
  457.     return TCL_OK;
  458. }
  459.  
  460. /*
  461.  *----------------------------------------------------------------------
  462.  *
  463.  * Tcl_SeekCmd --
  464.  *
  465.  *    This procedure is invoked to process the Tcl "seek" command. See
  466.  *    the user documentation for details on what it does.
  467.  *
  468.  * Results:
  469.  *    A standard Tcl result.
  470.  *
  471.  * Side effects:
  472.  *    Moves the position of the access point on the specified channel.
  473.  *    May flush queued output.
  474.  *
  475.  *----------------------------------------------------------------------
  476.  */
  477.  
  478.     /* ARGSUSED */
  479. int
  480. Tcl_SeekCmd(clientData, interp, argc, argv)
  481.     ClientData clientData;        /* Not used. */
  482.     Tcl_Interp *interp;            /* Current interpreter. */
  483.     int argc;                /* Number of arguments. */
  484.     char **argv;            /* Argument strings. */
  485. {
  486.     Tcl_Channel chan;            /* The channel to tell on. */
  487.     int offset, mode;            /* Where to seek? */
  488.     int result;                /* Of calling Tcl_Seek. */
  489.  
  490.     if ((argc != 3) && (argc != 4)) {
  491.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  492.         " channelId offset ?origin?\"", (char *) NULL);
  493.     return TCL_ERROR;
  494.     }
  495.     chan = Tcl_GetChannel(interp, argv[1], NULL);
  496.     if (chan == (Tcl_Channel) NULL) {
  497.     return TCL_ERROR;
  498.     }
  499.     if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) {
  500.     return TCL_ERROR;
  501.     }
  502.     mode = SEEK_SET;
  503.     if (argc == 4) {
  504.     size_t length;
  505.     int c;
  506.  
  507.     length = strlen(argv[3]);
  508.     c = argv[3][0];
  509.     if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) {
  510.         mode = SEEK_SET;
  511.     } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) {
  512.         mode = SEEK_CUR;
  513.     } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) {
  514.         mode = SEEK_END;
  515.     } else {
  516.         Tcl_AppendResult(interp, "bad origin \"", argv[3],
  517.             "\": should be start, current, or end", (char *) NULL);
  518.         return TCL_ERROR;
  519.     }
  520.     }
  521.  
  522.     result = Tcl_Seek(chan, offset, mode);
  523.     if (result == -1) {
  524.         Tcl_AppendResult(interp, "error during seek on \"", 
  525.         Tcl_GetChannelName(chan), "\": ",
  526.                 Tcl_PosixError(interp), (char *) NULL);
  527.         return TCL_ERROR;
  528.     }
  529.     return TCL_OK;
  530. }
  531.  
  532. /*
  533.  *----------------------------------------------------------------------
  534.  *
  535.  * Tcl_TellCmd --
  536.  *
  537.  *    This procedure is invoked to process the Tcl "tell" command.
  538.  *    See the user documentation for details on what it does.
  539.  *
  540.  * Results:
  541.  *    A standard Tcl result.
  542.  *
  543.  * Side effects:
  544.  *    None.
  545.  *
  546.  *----------------------------------------------------------------------
  547.  */
  548.  
  549.     /* ARGSUSED */
  550. int
  551. Tcl_TellCmd(clientData, interp, argc, argv)
  552.     ClientData clientData;        /* Not used. */
  553.     Tcl_Interp *interp;            /* Current interpreter. */
  554.     int argc;                /* Number of arguments. */
  555.     char **argv;            /* Argument strings. */
  556. {
  557.     Tcl_Channel chan;            /* The channel to tell on. */
  558.     char buf[40];
  559.  
  560.     if (argc != 2) {
  561.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  562.         " channelId\"", (char *) NULL);
  563.     return TCL_ERROR;
  564.     }
  565.     /*
  566.      * Try to find a channel with the right name and permissions in
  567.      * the IO channel table of this interpreter.
  568.      */
  569.     
  570.     chan = Tcl_GetChannel(interp, argv[1], NULL);
  571.     if (chan == (Tcl_Channel) NULL) {
  572.     return TCL_ERROR;
  573.     }
  574.     TclFormatInt(buf, Tcl_Tell(chan));
  575.     Tcl_SetResult(interp, buf, TCL_VOLATILE);
  576.     return TCL_OK;
  577. }
  578.  
  579. /*
  580.  *----------------------------------------------------------------------
  581.  *
  582.  * Tcl_CloseObjCmd --
  583.  *
  584.  *    This procedure is invoked to process the Tcl "close" command.
  585.  *    See the user documentation for details on what it does.
  586.  *
  587.  * Results:
  588.  *    A standard Tcl result.
  589.  *
  590.  * Side effects:
  591.  *    May discard queued input; may flush queued output.
  592.  *
  593.  *----------------------------------------------------------------------
  594.  */
  595.  
  596.     /* ARGSUSED */
  597. int
  598. Tcl_CloseObjCmd(clientData, interp, objc, objv)
  599.     ClientData clientData;    /* Not used. */
  600.     Tcl_Interp *interp;        /* Current interpreter. */
  601.     int objc;            /* Number of arguments. */
  602.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  603. {
  604.     Tcl_Channel chan;            /* The channel to close. */
  605.     int len;                /* Length of error output. */
  606.     char *arg;
  607.  
  608.     if (objc != 2) {
  609.     Tcl_WrongNumArgs(interp, 1, objv, "channelId");
  610.     return TCL_ERROR;
  611.     }
  612.  
  613.     arg = Tcl_GetStringFromObj(objv[1], NULL);
  614.     chan = Tcl_GetChannel(interp, arg, NULL);
  615.     if (chan == (Tcl_Channel) NULL) {
  616.     return TCL_ERROR;
  617.     }
  618.  
  619.     if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
  620.         /*
  621.          * If there is an error message and it ends with a newline, remove
  622.          * the newline. This is done for command pipeline channels where the
  623.          * error output from the subprocesses is stored in interp->result.
  624.          *
  625.          * NOTE: This is likely to not have any effect on regular error
  626.          * messages produced by drivers during the closing of a channel,
  627.          * because the Tcl convention is that such error messages do not
  628.          * have a terminating newline.
  629.          */
  630.  
  631.         len = strlen(interp->result);
  632.         if ((len > 0) && (interp->result[len - 1] == '\n')) {
  633.             interp->result[len - 1] = '\0';
  634.         }
  635.         
  636.         return TCL_ERROR;
  637.     }
  638.  
  639.     return TCL_OK;
  640. }
  641.  
  642. /*
  643.  *----------------------------------------------------------------------
  644.  *
  645.  * Tcl_FconfigureCmd --
  646.  *
  647.  *    This procedure is invoked to process the Tcl "fconfigure" command.
  648.  *    See the user documentation for details on what it does.
  649.  *
  650.  * Results:
  651.  *    A standard Tcl result.
  652.  *
  653.  * Side effects:
  654.  *    May modify the behavior of an IO channel.
  655.  *
  656.  *----------------------------------------------------------------------
  657.  */
  658.  
  659.     /* ARGSUSED */
  660. int
  661. Tcl_FconfigureCmd(clientData, interp, argc, argv)
  662.     ClientData clientData;        /* Not used. */
  663.     Tcl_Interp *interp;            /* Current interpreter. */
  664.     int argc;                /* Number of arguments. */
  665.     char **argv;            /* Argument strings. */
  666. {
  667.     Tcl_Channel chan;            /* The channel to set a mode on. */
  668.     int i;                /* Iterate over arg-value pairs. */
  669.     Tcl_DString ds;            /* DString to hold result of
  670.                                          * calling Tcl_GetChannelOption. */
  671.  
  672.     if ((argc < 2) || (((argc % 2) == 1) && (argc != 3))) {
  673.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  674.                 " channelId ?optionName? ?value? ?optionName value?...\"",
  675.                 (char *) NULL);
  676.         return TCL_ERROR;
  677.     }
  678.     chan = Tcl_GetChannel(interp, argv[1], NULL);
  679.     if (chan == (Tcl_Channel) NULL) {
  680.         return TCL_ERROR;
  681.     }
  682.     if (argc == 2) {
  683.         Tcl_DStringInit(&ds);
  684.         if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) {
  685.         Tcl_DStringFree(&ds);
  686.         return TCL_ERROR;
  687.         }
  688.         Tcl_DStringResult(interp, &ds);
  689.         return TCL_OK;
  690.     }
  691.     if (argc == 3) {
  692.         Tcl_DStringInit(&ds);
  693.         if (Tcl_GetChannelOption(interp, chan, argv[2], &ds) != TCL_OK) {
  694.             Tcl_DStringFree(&ds);
  695.             return TCL_ERROR;
  696.         }
  697.         Tcl_DStringResult(interp, &ds);
  698.         return TCL_OK;
  699.     }
  700.     for (i = 3; i < argc; i += 2) {
  701.         if (Tcl_SetChannelOption(interp, chan, argv[i-1], argv[i]) != TCL_OK) {
  702.             return TCL_ERROR;
  703.         }
  704.     }
  705.     return TCL_OK;
  706. }
  707.  
  708. /*
  709.  *----------------------------------------------------------------------
  710.  *
  711.  * Tcl_EofObjCmd --
  712.  *
  713.  *    This procedure is invoked to process the Tcl "eof" command.
  714.  *    See the user documentation for details on what it does.
  715.  *
  716.  * Results:
  717.  *    A standard Tcl result.
  718.  *
  719.  * Side effects:
  720.  *    Sets interp->result to "0" or "1" depending on whether the
  721.  *    specified channel has an EOF condition.
  722.  *
  723.  *----------------------------------------------------------------------
  724.  */
  725.  
  726.     /* ARGSUSED */
  727. int
  728. Tcl_EofObjCmd(unused, interp, objc, objv)
  729.     ClientData unused;        /* Not used. */
  730.     Tcl_Interp *interp;        /* Current interpreter. */
  731.     int objc;            /* Number of arguments. */
  732.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  733. {
  734.     Tcl_Channel chan;            /* The channel to query for EOF. */
  735.     int mode;                /* Mode in which channel is opened. */
  736.     char buf[40];
  737.     char *arg;
  738.  
  739.     if (objc != 2) {
  740.     Tcl_WrongNumArgs(interp, 1, objv, "channelId");
  741.         return TCL_ERROR;
  742.     }
  743.  
  744.     arg = Tcl_GetStringFromObj(objv[1], NULL);
  745.     chan = Tcl_GetChannel(interp, arg, &mode);
  746.     if (chan == (Tcl_Channel) NULL) {
  747.     return TCL_ERROR;
  748.     }
  749.  
  750.     TclFormatInt(buf, Tcl_Eof(chan) ? 1 : 0);
  751.     Tcl_SetResult(interp, buf, TCL_VOLATILE);
  752.     return TCL_OK;
  753. }
  754.  
  755. /*
  756.  *----------------------------------------------------------------------
  757.  *
  758.  * Tcl_ExecCmd --
  759.  *
  760.  *    This procedure is invoked to process the "exec" Tcl command.
  761.  *    See the user documentation for details on what it does.
  762.  *
  763.  * Results:
  764.  *    A standard Tcl result.
  765.  *
  766.  * Side effects:
  767.  *    See the user documentation.
  768.  *
  769.  *----------------------------------------------------------------------
  770.  */
  771.  
  772.     /* ARGSUSED */
  773. int
  774. Tcl_ExecCmd(dummy, interp, argc, argv)
  775.     ClientData dummy;            /* Not used. */
  776.     Tcl_Interp *interp;            /* Current interpreter. */
  777.     int argc;                /* Number of arguments. */
  778.     char **argv;            /* Argument strings. */
  779. {
  780. #ifdef MAC_TCL
  781.     Tcl_AppendResult(interp, "exec not implemented under Mac OS",
  782.         (char *)NULL);
  783.     return TCL_ERROR;
  784. #else /* !MAC_TCL */
  785.     int keepNewline, firstWord, background, length, result;
  786.     Tcl_Channel chan;
  787.     Tcl_DString ds;
  788.     int readSoFar, readNow, bufSize;
  789.  
  790.     /*
  791.      * Check for a leading "-keepnewline" argument.
  792.      */
  793.  
  794.     keepNewline = 0;
  795.     for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-');
  796.       firstWord++) {
  797.     if (strcmp(argv[firstWord], "-keepnewline") == 0) {
  798.         keepNewline = 1;
  799.     } else if (strcmp(argv[firstWord], "--") == 0) {
  800.         firstWord++;
  801.         break;
  802.     } else {
  803.         Tcl_AppendResult(interp, "bad switch \"", argv[firstWord],
  804.             "\": must be -keepnewline or --", (char *) NULL);
  805.         return TCL_ERROR;
  806.     }
  807.     }
  808.  
  809.     if (argc <= firstWord) {
  810.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  811.         " ?switches? arg ?arg ...?\"", (char *) NULL);
  812.     return TCL_ERROR;
  813.     }
  814.  
  815.     /*
  816.      * See if the command is to be run in background.
  817.      */
  818.  
  819.     background = 0;
  820.     if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) {
  821.     argc--;
  822.     argv[argc] = NULL;
  823.         background = 1;
  824.     }
  825.     
  826.     chan = Tcl_OpenCommandChannel(interp, argc-firstWord,
  827.             argv+firstWord,
  828.         (background ? 0 : TCL_STDOUT | TCL_STDERR));
  829.  
  830.     if (chan == (Tcl_Channel) NULL) {
  831.         return TCL_ERROR;
  832.     }
  833.  
  834.     if (background) {
  835.  
  836.         /*
  837.          * Get the list of PIDs from the pipeline into interp->result and
  838.          * detach the PIDs (instead of waiting for them).
  839.          */
  840.  
  841.         TclGetAndDetachPids(interp, chan);
  842.         
  843.         if (Tcl_Close(interp, chan) != TCL_OK) {
  844.             return TCL_ERROR;
  845.         }
  846.         return TCL_OK;
  847.     }
  848.  
  849.     if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
  850. #define    EXEC_BUFFER_SIZE 4096
  851.  
  852.         Tcl_DStringInit(&ds);
  853.         readSoFar = 0; bufSize = 0;
  854.         while (1) {
  855.             bufSize += EXEC_BUFFER_SIZE;
  856.             Tcl_DStringSetLength(&ds, bufSize);
  857.             readNow = Tcl_Read(chan, Tcl_DStringValue(&ds) + readSoFar,
  858.                     EXEC_BUFFER_SIZE);
  859.             if (readNow < 0) {
  860.                 Tcl_DStringFree(&ds);
  861.         Tcl_AppendResult(interp,
  862.             "error reading output from command: ",
  863.             Tcl_PosixError(interp), (char *) NULL);
  864.                 return TCL_ERROR;
  865.             }
  866.             readSoFar += readNow;
  867.             if (readNow < EXEC_BUFFER_SIZE) {
  868.                 break;    /* Out of "while (1)" loop. */
  869.             }
  870.         }
  871.         Tcl_DStringSetLength(&ds, readSoFar);
  872.         Tcl_DStringResult(interp, &ds);
  873.     }
  874.  
  875.     result = Tcl_Close(interp, chan);
  876.  
  877.     /*
  878.      * If the last character of interp->result is a newline, then remove
  879.      * the newline character (the newline would just confuse things).
  880.      * Special hack: must replace the old terminating null character
  881.      * as a signal to Tcl_AppendResult et al. that we've mucked with
  882.      * the string.
  883.      */
  884.     
  885.     length = strlen(interp->result);
  886.     if (!keepNewline && (length > 0) &&
  887.         (interp->result[length-1] == '\n')) {
  888.         interp->result[length-1] = '\0';
  889.         interp->result[length] = 'x';
  890.     }
  891.  
  892.     return result;
  893. #endif /* !MAC_TCL */
  894. }
  895.  
  896. /*
  897.  *----------------------------------------------------------------------
  898.  *
  899.  * Tcl_FblockedObjCmd --
  900.  *
  901.  *    This procedure is invoked to process the Tcl "fblocked" command.
  902.  *    See the user documentation for details on what it does.
  903.  *
  904.  * Results:
  905.  *    A standard Tcl result.
  906.  *
  907.  * Side effects:
  908.  *    Sets interp->result to "0" or "1" depending on whether the
  909.  *    a preceding input operation on the channel would have blocked.
  910.  *
  911.  *----------------------------------------------------------------------
  912.  */
  913.  
  914.     /* ARGSUSED */
  915. int
  916. Tcl_FblockedObjCmd(unused, interp, objc, objv)
  917.     ClientData unused;        /* Not used. */
  918.     Tcl_Interp *interp;        /* Current interpreter. */
  919.     int objc;            /* Number of arguments. */
  920.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  921. {
  922.     Tcl_Channel chan;            /* The channel to query for blocked. */
  923.     int mode;                /* Mode in which channel was opened. */
  924.     char buf[40];
  925.     char *arg;
  926.  
  927.     if (objc != 2) {
  928.     Tcl_WrongNumArgs(interp, 1, objv, "channelId");
  929.         return TCL_ERROR;
  930.     }
  931.  
  932.     arg = Tcl_GetStringFromObj(objv[1], NULL);
  933.     chan = Tcl_GetChannel(interp, arg, &mode);
  934.     if (chan == (Tcl_Channel) NULL) {
  935.         return TCL_ERROR;
  936.     }
  937.     if ((mode & TCL_READABLE) == 0) {
  938.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
  939.         Tcl_GetStringFromObj(objv[1], NULL), 
  940.                 "\" wasn't opened for reading", (char *) NULL);
  941.         return TCL_ERROR;
  942.     }
  943.         
  944.     TclFormatInt(buf, Tcl_InputBlocked(chan) ? 1 : 0);
  945.     Tcl_SetResult(interp, buf, TCL_VOLATILE);
  946.     return TCL_OK;
  947. }
  948.  
  949. /*
  950.  *----------------------------------------------------------------------
  951.  *
  952.  * Tcl_OpenCmd --
  953.  *
  954.  *    This procedure is invoked to process the "open" Tcl command.
  955.  *    See the user documentation for details on what it does.
  956.  *
  957.  * Results:
  958.  *    A standard Tcl result.
  959.  *
  960.  * Side effects:
  961.  *    See the user documentation.
  962.  *
  963.  *----------------------------------------------------------------------
  964.  */
  965.  
  966.     /* ARGSUSED */
  967. int
  968. Tcl_OpenCmd(notUsed, interp, argc, argv)
  969.     ClientData notUsed;            /* Not used. */
  970.     Tcl_Interp *interp;            /* Current interpreter. */
  971.     int argc;                /* Number of arguments. */
  972.     char **argv;            /* Argument strings. */
  973. {
  974.     int pipeline, prot;
  975.     char *modeString;
  976.     Tcl_Channel chan;
  977.  
  978.     if ((argc < 2) || (argc > 4)) {
  979.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  980.         " fileName ?access? ?permissions?\"", (char *) NULL);
  981.     return TCL_ERROR;
  982.     }
  983.     prot = 0666;
  984.     if (argc == 2) {
  985.     modeString = "r";
  986.     } else {
  987.     modeString = argv[2];
  988.     if (argc == 4) {
  989.         if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) {
  990.         return TCL_ERROR;
  991.         }
  992.     }
  993.     }
  994.  
  995.     pipeline = 0;
  996.     if (argv[1][0] == '|') {
  997.     pipeline = 1;
  998.     }
  999.  
  1000.     /*
  1001.      * Open the file or create a process pipeline.
  1002.      */
  1003.  
  1004.     if (!pipeline) {
  1005.         chan = Tcl_OpenFileChannel(interp, argv[1], modeString, prot);
  1006.     } else {
  1007. #ifdef MAC_TCL
  1008.     Tcl_AppendResult(interp,
  1009.         "command pipelines not supported on Macintosh OS",
  1010.         (char *)NULL);
  1011.     return TCL_ERROR;
  1012. #else
  1013.     int mode, seekFlag, cmdArgc;
  1014.     char **cmdArgv;
  1015.  
  1016.         if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) {
  1017.             return TCL_ERROR;
  1018.         }
  1019.  
  1020.         mode = TclGetOpenMode(interp, modeString, &seekFlag);
  1021.         if (mode == -1) {
  1022.         chan = NULL;
  1023.         } else {
  1024.         int flags = TCL_STDERR | TCL_ENFORCE_MODE;
  1025.         switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
  1026.         case O_RDONLY:
  1027.             flags |= TCL_STDOUT;
  1028.             break;
  1029.         case O_WRONLY:
  1030.             flags |= TCL_STDIN;
  1031.             break;
  1032.         case O_RDWR:
  1033.             flags |= (TCL_STDIN | TCL_STDOUT);
  1034.             break;
  1035.         default:
  1036.             panic("Tcl_OpenCmd: invalid mode value");
  1037.             break;
  1038.         }
  1039.         chan = Tcl_OpenCommandChannel(interp, cmdArgc, cmdArgv, flags);
  1040.     }
  1041.         ckfree((char *) cmdArgv);
  1042. #endif
  1043.     }
  1044.     if (chan == (Tcl_Channel) NULL) {
  1045.         return TCL_ERROR;
  1046.     }
  1047.     Tcl_RegisterChannel(interp, chan);
  1048.     Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
  1049.     return TCL_OK;
  1050. }
  1051.  
  1052. /*
  1053.  *----------------------------------------------------------------------
  1054.  *
  1055.  * TcpAcceptCallbacksDeleteProc --
  1056.  *
  1057.  *    Assocdata cleanup routine called when an interpreter is being
  1058.  *    deleted to set the interp field of all the accept callback records
  1059.  *    registered with    the interpreter to NULL. This will prevent the
  1060.  *    interpreter from being used in the future to eval accept scripts.
  1061.  *
  1062.  * Results:
  1063.  *    None.
  1064.  *
  1065.  * Side effects:
  1066.  *    Deallocates memory and sets the interp field of all the accept
  1067.  *    callback records to NULL to prevent this interpreter from being
  1068.  *    used subsequently to eval accept scripts.
  1069.  *
  1070.  *----------------------------------------------------------------------
  1071.  */
  1072.  
  1073.     /* ARGSUSED */
  1074. static void
  1075. TcpAcceptCallbacksDeleteProc(clientData, interp)
  1076.     ClientData clientData;    /* Data which was passed when the assocdata
  1077.                                  * was registered. */
  1078.     Tcl_Interp *interp;        /* Interpreter being deleted - not used. */
  1079. {
  1080.     Tcl_HashTable *hTblPtr;
  1081.     Tcl_HashEntry *hPtr;
  1082.     Tcl_HashSearch hSearch;
  1083.     AcceptCallback *acceptCallbackPtr;
  1084.  
  1085.     hTblPtr = (Tcl_HashTable *) clientData;
  1086.     for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
  1087.              hPtr != (Tcl_HashEntry *) NULL;
  1088.              hPtr = Tcl_NextHashEntry(&hSearch)) {
  1089.         acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr);
  1090.         acceptCallbackPtr->interp = (Tcl_Interp *) NULL;
  1091.     }
  1092.     Tcl_DeleteHashTable(hTblPtr);
  1093.     ckfree((char *) hTblPtr);
  1094. }
  1095.  
  1096. /*
  1097.  *----------------------------------------------------------------------
  1098.  *
  1099.  * RegisterTcpServerInterpCleanup --
  1100.  *
  1101.  *    Registers an accept callback record to have its interp
  1102.  *    field set to NULL when the interpreter is deleted.
  1103.  *
  1104.  * Results:
  1105.  *    None.
  1106.  *
  1107.  * Side effects:
  1108.  *    When, in the future, the interpreter is deleted, the interp
  1109.  *    field of the accept callback data structure will be set to
  1110.  *    NULL. This will prevent attempts to eval the accept script
  1111.  *    in a deleted interpreter.
  1112.  *
  1113.  *----------------------------------------------------------------------
  1114.  */
  1115.  
  1116. static void
  1117. RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr)
  1118.     Tcl_Interp *interp;        /* Interpreter for which we want to be
  1119.                                  * informed of deletion. */
  1120.     AcceptCallback *acceptCallbackPtr;
  1121.                     /* The accept callback record whose
  1122.                                  * interp field we want set to NULL when
  1123.                                  * the interpreter is deleted. */
  1124. {
  1125.     Tcl_HashTable *hTblPtr;    /* Hash table for accept callback
  1126.                                  * records to smash when the interpreter
  1127.                                  * will be deleted. */
  1128.     Tcl_HashEntry *hPtr;    /* Entry for this record. */
  1129.     int new;            /* Is the entry new? */
  1130.  
  1131.     hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
  1132.             "tclTCPAcceptCallbacks",
  1133.             NULL);
  1134.     if (hTblPtr == (Tcl_HashTable *) NULL) {
  1135.         hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
  1136.         Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
  1137.         (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
  1138.                 TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr);
  1139.     }
  1140.     hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new);
  1141.     if (!new) {
  1142.         panic("RegisterTcpServerCleanup: damaged accept record table");
  1143.     }
  1144.     Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr);
  1145. }
  1146.  
  1147. /*
  1148.  *----------------------------------------------------------------------
  1149.  *
  1150.  * UnregisterTcpServerInterpCleanupProc --
  1151.  *
  1152.  *    Unregister a previously registered accept callback record. The
  1153.  *    interp field of this record will no longer be set to NULL in
  1154.  *    the future when the interpreter is deleted.
  1155.  *
  1156.  * Results:
  1157.  *    None.
  1158.  *
  1159.  * Side effects:
  1160.  *    Prevents the interp field of the accept callback record from
  1161.  *    being set to NULL in the future when the interpreter is deleted.
  1162.  *
  1163.  *----------------------------------------------------------------------
  1164.  */
  1165.  
  1166. static void
  1167. UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr)
  1168.     Tcl_Interp *interp;        /* Interpreter in which the accept callback
  1169.                                  * record was registered. */
  1170.     AcceptCallback *acceptCallbackPtr;
  1171.                     /* The record for which to delete the
  1172.                                  * registration. */
  1173. {
  1174.     Tcl_HashTable *hTblPtr;
  1175.     Tcl_HashEntry *hPtr;
  1176.  
  1177.     hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
  1178.             "tclTCPAcceptCallbacks", NULL);
  1179.     if (hTblPtr == (Tcl_HashTable *) NULL) {
  1180.         return;
  1181.     }
  1182.     hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
  1183.     if (hPtr == (Tcl_HashEntry *) NULL) {
  1184.         return;
  1185.     }
  1186.     Tcl_DeleteHashEntry(hPtr);
  1187. }
  1188.  
  1189. /*
  1190.  *----------------------------------------------------------------------
  1191.  *
  1192.  * AcceptCallbackProc --
  1193.  *
  1194.  *    This callback is invoked by the TCP channel driver when it
  1195.  *    accepts a new connection from a client on a server socket.
  1196.  *
  1197.  * Results:
  1198.  *    None.
  1199.  *
  1200.  * Side effects:
  1201.  *    Whatever the script does.
  1202.  *
  1203.  *----------------------------------------------------------------------
  1204.  */
  1205.  
  1206. static void
  1207. AcceptCallbackProc(callbackData, chan, address, port)
  1208.     ClientData callbackData;        /* The data stored when the callback
  1209.                                          * was created in the call to
  1210.                                          * Tcl_OpenTcpServer. */
  1211.     Tcl_Channel chan;            /* Channel for the newly accepted
  1212.                                          * connection. */
  1213.     char *address;            /* Address of client that was
  1214.                                          * accepted. */
  1215.     int port;                /* Port of client that was accepted. */
  1216. {
  1217.     AcceptCallback *acceptCallbackPtr;
  1218.     Tcl_Interp *interp;
  1219.     char *script;
  1220.     char portBuf[10];
  1221.     int result;
  1222.  
  1223.     acceptCallbackPtr = (AcceptCallback *) callbackData;
  1224.  
  1225.     /*
  1226.      * Check if the callback is still valid; the interpreter may have gone
  1227.      * away, this is signalled by setting the interp field of the callback
  1228.      * data to NULL.
  1229.      */
  1230.     
  1231.     if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
  1232.  
  1233.         script = acceptCallbackPtr->script;
  1234.         interp = acceptCallbackPtr->interp;
  1235.         
  1236.         Tcl_Preserve((ClientData) script);
  1237.         Tcl_Preserve((ClientData) interp);
  1238.  
  1239.     TclFormatInt(portBuf, port);
  1240.         Tcl_RegisterChannel(interp, chan);
  1241.         result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
  1242.                 " ", address, " ", portBuf, (char *) NULL);
  1243.         if (result != TCL_OK) {
  1244.             Tcl_BackgroundError(interp);
  1245.         Tcl_UnregisterChannel(interp, chan);
  1246.         }
  1247.         Tcl_Release((ClientData) interp);
  1248.         Tcl_Release((ClientData) script);
  1249.     } else {
  1250.  
  1251.         /*
  1252.          * The interpreter has been deleted, so there is no useful
  1253.          * way to utilize the client socket - just close it.
  1254.          */
  1255.  
  1256.         Tcl_Close((Tcl_Interp *) NULL, chan);
  1257.     }
  1258. }
  1259.  
  1260. /*
  1261.  *----------------------------------------------------------------------
  1262.  *
  1263.  * TcpServerCloseProc --
  1264.  *
  1265.  *    This callback is called when the TCP server channel for which it
  1266.  *    was registered is being closed. It informs the interpreter in
  1267.  *    which the accept script is evaluated (if that interpreter still
  1268.  *    exists) that this channel no longer needs to be informed if the
  1269.  *    interpreter is deleted.
  1270.  *
  1271.  * Results:
  1272.  *    None.
  1273.  *
  1274.  * Side effects:
  1275.  *    In the future, if the interpreter is deleted this channel will
  1276.  *    no longer be informed.
  1277.  *
  1278.  *----------------------------------------------------------------------
  1279.  */
  1280.  
  1281. static void
  1282. TcpServerCloseProc(callbackData)
  1283.     ClientData callbackData;    /* The data passed in the call to
  1284.                                  * Tcl_CreateCloseHandler. */
  1285. {
  1286.     AcceptCallback *acceptCallbackPtr;
  1287.                     /* The actual data. */
  1288.  
  1289.     acceptCallbackPtr = (AcceptCallback *) callbackData;
  1290.     if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
  1291.         UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
  1292.                 acceptCallbackPtr);
  1293.     }
  1294.     Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC);
  1295.     ckfree((char *) acceptCallbackPtr);
  1296. }
  1297.  
  1298. /*
  1299.  *----------------------------------------------------------------------
  1300.  *
  1301.  * Tcl_SocketCmd --
  1302.  *
  1303.  *    This procedure is invoked to process the "socket" Tcl command.
  1304.  *    See the user documentation for details on what it does.
  1305.  *
  1306.  * Results:
  1307.  *    A standard Tcl result.
  1308.  *
  1309.  * Side effects:
  1310.  *    Creates a socket based channel.
  1311.  *
  1312.  *----------------------------------------------------------------------
  1313.  */
  1314.  
  1315. int
  1316. Tcl_SocketCmd(notUsed, interp, argc, argv)
  1317.     ClientData notUsed;            /* Not used. */
  1318.     Tcl_Interp *interp;            /* Current interpreter. */
  1319.     int argc;                /* Number of arguments. */
  1320.     char **argv;            /* Argument strings. */
  1321. {
  1322.     int a, server, port;
  1323.     char *arg, *copyScript, *host, *script;
  1324.     char *myaddr = NULL;
  1325.     int myport = 0;
  1326.     int async = 0;
  1327.     Tcl_Channel chan;
  1328.     AcceptCallback *acceptCallbackPtr;
  1329.     
  1330.     server = 0;
  1331.     script = NULL;
  1332.  
  1333.     if (TclHasSockets(interp) != TCL_OK) {
  1334.     return TCL_ERROR;
  1335.     }
  1336.  
  1337.     for (a = 1; a < argc; a++) {
  1338.         arg = argv[a];
  1339.     if (arg[0] == '-') {
  1340.         if (strcmp(arg, "-server") == 0) {
  1341.                 if (async == 1) {
  1342.                     Tcl_AppendResult(interp,
  1343.                             "cannot set -async option for server sockets",
  1344.                             (char *) NULL);
  1345.                     return TCL_ERROR;
  1346.                 }
  1347.         server = 1;
  1348.         a++;
  1349.         if (a >= argc) {
  1350.             Tcl_AppendResult(interp,
  1351.                 "no argument given for -server option",
  1352.                             (char *) NULL);
  1353.             return TCL_ERROR;
  1354.         }
  1355.                 script = argv[a];
  1356.             } else if (strcmp(arg, "-myaddr") == 0) {
  1357.         a++;
  1358.                 if (a >= argc) {
  1359.             Tcl_AppendResult(interp,
  1360.                 "no argument given for -myaddr option",
  1361.                             (char *) NULL);
  1362.             return TCL_ERROR;
  1363.         }
  1364.                 myaddr = argv[a];
  1365.             } else if (strcmp(arg, "-myport") == 0) {
  1366.         a++;
  1367.                 if (a >= argc) {
  1368.             Tcl_AppendResult(interp,
  1369.                 "no argument given for -myport option",
  1370.                             (char *) NULL);
  1371.             return TCL_ERROR;
  1372.         }
  1373.         if (TclSockGetPort(interp, argv[a], "tcp", &myport)
  1374.                     != TCL_OK) {
  1375.             return TCL_ERROR;
  1376.         }
  1377.             } else if (strcmp(arg, "-async") == 0) {
  1378.                 if (server == 1) {
  1379.                     Tcl_AppendResult(interp,
  1380.                             "cannot set -async option for server sockets",
  1381.                             (char *) NULL);
  1382.                     return TCL_ERROR;
  1383.                 }
  1384.                 async = 1;
  1385.         } else {
  1386.         Tcl_AppendResult(interp, "bad option \"", arg,
  1387.                         "\", must be -async, -myaddr, -myport, or -server",
  1388.                         (char *) NULL);
  1389.         return TCL_ERROR;
  1390.         }
  1391.     } else {
  1392.         break;
  1393.     }
  1394.     }
  1395.     if (server) {
  1396.         host = myaddr;        /* NULL implies INADDR_ANY */
  1397.     if (myport != 0) {
  1398.         Tcl_AppendResult(interp, "Option -myport is not valid for servers",
  1399.             NULL);
  1400.         return TCL_ERROR;
  1401.     }
  1402.     } else if (a < argc) {
  1403.     host = argv[a];
  1404.     a++;
  1405.     } else {
  1406. wrongNumArgs:
  1407.     Tcl_AppendResult(interp, "wrong # args: should be either:\n",
  1408.         argv[0],
  1409.                 " ?-myaddr addr? ?-myport myport? ?-async? host port\n",
  1410.         argv[0],
  1411.                 " -server command ?-myaddr addr? port",
  1412.                 (char *) NULL);
  1413.         return TCL_ERROR;
  1414.     }
  1415.  
  1416.     if (a == argc-1) {
  1417.     if (TclSockGetPort(interp, argv[a], "tcp", &port) != TCL_OK) {
  1418.         return TCL_ERROR;
  1419.     }
  1420.     } else {
  1421.     goto wrongNumArgs;
  1422.     }
  1423.  
  1424.     if (server) {
  1425.         acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned)
  1426.                 sizeof(AcceptCallback));
  1427.         copyScript = ckalloc((unsigned) strlen(script) + 1);
  1428.         strcpy(copyScript, script);
  1429.         acceptCallbackPtr->script = copyScript;
  1430.         acceptCallbackPtr->interp = interp;
  1431.         chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
  1432.                 (ClientData) acceptCallbackPtr);
  1433.         if (chan == (Tcl_Channel) NULL) {
  1434.             ckfree(copyScript);
  1435.             ckfree((char *) acceptCallbackPtr);
  1436.             return TCL_ERROR;
  1437.         }
  1438.  
  1439.         /*
  1440.          * Register with the interpreter to let us know when the
  1441.          * interpreter is deleted (by having the callback set the
  1442.          * acceptCallbackPtr->interp field to NULL). This is to
  1443.          * avoid trying to eval the script in a deleted interpreter.
  1444.          */
  1445.  
  1446.         RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr);
  1447.         
  1448.         /*
  1449.          * Register a close callback. This callback will inform the
  1450.          * interpreter (if it still exists) that this channel does not
  1451.          * need to be informed when the interpreter is deleted.
  1452.          */
  1453.         
  1454.         Tcl_CreateCloseHandler(chan, TcpServerCloseProc,
  1455.                 (ClientData) acceptCallbackPtr);
  1456.     } else {
  1457.         chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
  1458.         if (chan == (Tcl_Channel) NULL) {
  1459.             return TCL_ERROR;
  1460.         }
  1461.     }
  1462.     Tcl_RegisterChannel(interp, chan);            
  1463.     Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
  1464.     
  1465.     return TCL_OK;
  1466. }
  1467.  
  1468. /*
  1469.  *----------------------------------------------------------------------
  1470.  *
  1471.  * Tcl_FcopyObjCmd --
  1472.  *
  1473.  *    This procedure is invoked to process the "fcopy" Tcl command.
  1474.  *    See the user documentation for details on what it does.
  1475.  *
  1476.  * Results:
  1477.  *    A standard Tcl result.
  1478.  *
  1479.  * Side effects:
  1480.  *    Moves data between two channels and possibly sets up a
  1481.  *    background copy handler.
  1482.  *
  1483.  *----------------------------------------------------------------------
  1484.  */
  1485.  
  1486. int
  1487. Tcl_FcopyObjCmd(dummy, interp, objc, objv)
  1488.     ClientData dummy;        /* Not used. */
  1489.     Tcl_Interp *interp;        /* Current interpreter. */
  1490.     int objc;            /* Number of arguments. */
  1491.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1492. {
  1493.     Tcl_Channel inChan, outChan;
  1494.     char *arg;
  1495.     int mode, i;
  1496.     int toRead;
  1497.     Tcl_Obj *cmdPtr;
  1498.     static char* switches[] = { "-size", "-command", NULL };
  1499.     enum { FcopySize, FcopyCommand } index;
  1500.  
  1501.     if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
  1502.     Tcl_WrongNumArgs(interp, 1, objv,
  1503.         "input output ?-size size? ?-command callback?");
  1504.     return TCL_ERROR;
  1505.     }
  1506.  
  1507.     /*
  1508.      * Parse the channel arguments and verify that they are readable
  1509.      * or writable, as appropriate.
  1510.      */
  1511.  
  1512.     arg = Tcl_GetStringFromObj(objv[1], NULL);
  1513.     inChan = Tcl_GetChannel(interp, arg, &mode);
  1514.     if (inChan == (Tcl_Channel) NULL) {
  1515.     return TCL_ERROR;
  1516.     }
  1517.     if ((mode & TCL_READABLE) == 0) {
  1518.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
  1519.         Tcl_GetStringFromObj(objv[1], NULL), 
  1520.                 "\" wasn't opened for reading", (char *) NULL);
  1521.         return TCL_ERROR;
  1522.     }
  1523.     arg = Tcl_GetStringFromObj(objv[2], NULL);
  1524.     outChan = Tcl_GetChannel(interp, arg, &mode);
  1525.     if (outChan == (Tcl_Channel) NULL) {
  1526.     return TCL_ERROR;
  1527.     }
  1528.     if ((mode & TCL_WRITABLE) == 0) {
  1529.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
  1530.         Tcl_GetStringFromObj(objv[1], NULL), 
  1531.                 "\" wasn't opened for writing", (char *) NULL);
  1532.         return TCL_ERROR;
  1533.     }
  1534.  
  1535.     toRead = -1;
  1536.     cmdPtr = NULL;
  1537.     for (i = 3; i < objc; i += 2) {
  1538.     if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0,
  1539.         (int *) &index) != TCL_OK) {
  1540.         return TCL_ERROR;
  1541.     }
  1542.     switch (index) {
  1543.         case FcopySize:
  1544.         if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
  1545.             return TCL_ERROR;
  1546.         }
  1547.         break;
  1548.         case FcopyCommand:
  1549.         cmdPtr = objv[i+1];
  1550.         break;
  1551.     }
  1552.     }
  1553.  
  1554.     return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
  1555. }
  1556.